perm filename PFORM2.PAS[PAS,SYS] blob
sn#534210 filedate 1980-09-06 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00017 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 (*contents*)
C00009 00003 (*description and history*)
C00012 00004 (*valid switches*)
C00015 00005 (*global declarations*)
C00017 00006 VAR
C00027 00007 (*initialization:*) (*initprocedures,reinitialize,initialize*)
C00037 00008 (*ccl scanner:*) (*getdirectives[setswitch]*)
C00040 00009 (*page control:*) (*newpage*)
C00041 00010 (*output procs:*) (*block[error,writeline]*)
C00045 00011 (*scanner:*) (*insymbol[readbuffer[readline],resword*)
C00050 00012 (*parenthese,docomment*)
C00053 00013 (*] insymbol*)
C00058 00014 (*parsing of declarations:*) (*recdef[casedef,parenthese]*)
C00062 00015 (*parsing of statements:*) (*statement[endedstats,compstat,casestat,loopstat,ifstat,labelstat,repeatstat]*)
C00073 00016 (*]block*)
C00077 00017 (*main program*)
C00078 ENDMK
C⊗;
(*contents*)
(*page description*)
(*01*)
(*02*) (*$t-,r64,d- *) (*title page*)
(*03*) (*description and history*)
(*04*) (*valid switches*)
(*05*) (*global declarations*)
(*06*) (*var*)
(*07*) (*initialization:*) (*initprocedures,reinitialize,getcounts,initialize*)
(*08*) (*ccl scanner:*) (*getdirectives[setswitch]*)
(*09*) (*page control:*) (*newpage*)
(*10*) (*output procs:*) (*block[error,writeline]*)
(*11*) (*scanner:*) (*insymbol[readbuffer[readline],resword*)
(*12*) (*parenthese,docomment,skip←e←directory*)
(*13*) (*] insymbol*)
(*14*) (*parsing of declarations:*) (*recdef[casedef,parenthese]*)
(*15*) (*parsing of statements:*) (*statement[endedstats,compstat,casestat,loopstat,ifstat,labelstat,repeatstat]*)
(*16*) (*]block*)
(*17*) (*main program*)
(*$t-,r64,d- *) (*title page*)
(**********************************************************************
*
*
* p f o r m
* ---------
*
* reformats (prettyprints) a pascal source program.
*
* input: pascal source file. (oldsource)
* output: reformatted source file. (newsource)
*
* default input extension: none.
* default output extension: .new
* default output file name: same as the input name, with extension .new
*
* machine dependency: uses features supported by the pascal/passgo
* compilers for dec-10, dec-20, as implemented by armando r. rodriguez
* at stanford university.
*
* implementor: armando r. rodriguez
* p.o. box 5771
* stanford, ca 94305
* u.s.a.
*
* distributor: j. q. johnson
* lots computer facility
* stanford university
* stanford, ca 94305
* u.s.a.
*
* from an original cross-reference processor written by
* manuel mall, university of hamburg (1974) and distributed
* with the hamburg compiler for dec-10, dec-20 computers, by decus.
*
*
* part of the developement effort applied to this programs was performed
* as part of the effort in developement of programming languages and
* compilers at stanford university, under a subcontract from
* lawrence livermore laboratory to the computer science department, principal
* investigarors profs. forest baskett and john hennessy, contract no. ...
* lll po9628303. the s-1 work hardware development has been supported by
* the department of the navy via office of naval research order
* numbers n00014-76-f-0023, n00014-77-f-0023, and n00014-78-f-0023 to the
* university of california lawrence livermore laboratory (which is
* operated for the u. s. department of energy under contract no.
* w-7405-eng-48), from the computations group of the stanford linear
* accelerator center (supported by the u. s. department of energy under
* contract no. ey-76-c-03-0515), and from the stanford artificial
* intelligence laboratory (which receives support from the defense
* advanced research projects agency and the national science foundation).
*
(**********************************************************************
(*description and history*)
(**********************************************************************
*
* jul-79. armando r. rodriguez.
* + separate it into pform and pcref
* + adapt it for the lineprinter at sail.
* + improve the implementation of statement counts.
* + fix bugs.
*
* mar-79. armando r. rodriguez
* + implement statement counts.
*
* dec-78. armando r. rodriguez (stanford)
* + speed up and cleanning of the code.
* + fix small bugs.
*
* jul-78. armando r. rodriguez (stanford).
* + improve the cross reference listing.
* + listing of proc-func call nesting.
* + report the line numbers of begin and end of body of procedures.
*
* mar-78. armando r. rodriguez (stanford).
* + a new set of switch options.
* + some new errors are reported.
*
* date unknown. larry paulson (stanford).
* + make the files of type text
* + not as many forced newlines.
* + the report on procedure calls was cancelled.
*
*
(**********************************************************************)
(*valid switches*)
(*---------------------------------------------------------------------
!
! valid switches are: brackets indicate optional.
! <n> stands for an integer number.
! (defaults in parens are at sail) <l> stands for a letter.
!
! switch meaning default.
!
! files.
! /version:<n> behave as if conditionally compiling %<n>
! comments. -1
!
! page and line format
! /indent:<n> indentation between levels. 4,3 (lots,sail)
!
! statement format
! /begin:[-]<n> if the [-] is not there, the contents of a
! begin..end block is indented n spaces further.
! if it is there, the block will not be indented,
! but the begin and end statements will be
! exdented n spaces. 0
! /[no]force forces newline in standard places. (before and
! after begin, end, then, else, repeat, etc.) off
!
! upper and lower case
! note: the possible values for <l> are:
! u means upper case
! l means lower case.
!
! /res:<l> case used for reserved words. u
! /nonres:<l> same for non-reserved words. l
! /comm:<l> same for comments. l (u)
! /str:<l> same for strings. u
! /case:<l> resets all the defaults to <l>. off
!
+--------------------------------------------------------------------*)
(*global declarations*)
PROGRAM pform ;
CONST
version = 'PFORM/LOTS 1.1 6-SEP-79';
verlength = 10;
backslash = '\';
linsize = 600; (*maximum size of an input line*)
linsizplus2 = 602; (*linsize + 2*)
ht = 11B; (*ascii tab*)
blanks = ' '; (*for editing purposes*)
linnumsize = 5;
TYPE
pack6 = PACKED ARRAY[1..6] OF char;
pack9 = PACKED ARRAY[1..9] OF char;
pack15 = PACKED ARRAY[1..15] OF char;
errkinds = (begerrinblkstr,missgend,missgthen,missgof,missgexit,
missgrpar,missgquote,missgmain,missgpoint,linetoolong,
missgrbrack,missguntil);
symbol = (labelsy,constsy,typesy,varsy,programsy, (*decsym*)
functionsy,proceduresy,initprocsy, (*prosym*)
endsy,untilsy,elsesy,thensy,exitsy,ofsy,dosy,eobsy, (*endsymbols*)
beginsy,casesy,loopsy,repeatsy,ifsy, (*begsym*)
recordsy,forwardsy,gotosy,othersy,intconst,ident,strgconst,externsy,langsy,forsy,whilesy,
rbracket,rparent,semicolon,point,lparent,lbracket,colon,eqlsy,otherssy(*delimiter*));
linenrty = 0..maxint;
pagenrty = 0..maxint;
VAR
(* (*input control*)
(* (***************)
bufflen, (*length of the current line in the input buffer*)
buffmark, (*length of the already printed part of the buffer*)
bufferptr, (*pointer to the next character in the buffer*)
syleng: integer; (*length of the last read identifier or label*)
(* (*nesting and matching control*)
(* (******************************)
level, (*nesting depth of the current procedure*)
variant←level, (*nesting depth of variants*)
errcount: integer; (*counts the errors encountered*)
(* (*formatting*)
(* (************)
increment, (*line number increment*)
indentbegin, (*indentation after a begin*)
begexd, (*exdentation for begin-end pairs*)
feed, (*indentation by procedures and blocks*)
spaces, (*indentation for the current line*)
lastspaces, (*one-time overriding value for spaces*)
goodversion, (*keeps the value of the version option*)
pagecnt, (*counts the file pages*)
maxinc, (*greatest allowable line number*)
maxch, (*maximum length of source line in crosslist*)
line500, (*to give a tty message every 500 lines*)
linecnt : integer; (*counts the lines per file page*)
tabs: ARRAY [1:17] OF ascii; (*a string of tabs for formatting*)
lower : ARRAY [ascii] OF ascii; (*to map upper to lower case if desired*)
(* (*scanning*)
(* (**********)
buffer : ARRAY [-1..linsizplus2] OF ascii; (*input buffer*)
(* buffer has 2 extra positions on the left and one on the right*)
linenb : PACKED ARRAY [1..5] OF char; (*sos-line number*)
prog←name: alfa; (*name of current program*)
sy : alfa; (*last symbol read*)
syty : symbol; (*type of the last symbol read*)
(* (*version system*)
(* (****************)
incondcomp: boolean;
(* (*switches*)
(* (**********)
elseifing, (*set if the sequence else if should stay in one line*)
debugging, (*set if the unprinted counts are to be reported*)
forcing, (*set if then, else, do, repeat will force newline*)
rescase, (*set if reserved words will upshift*)
nonrcase, (*set if nonreserved words will upshift*)
comcase, (*set if comments will upshift*)
strcase, (*set if strings will upshift*)
thendo, (*set whenever 'spaces := spaces+dofeed' is executed*)
anyversion: boolean; (*set if goodversion > 9*)
(* (*other controls*)
(* (****************)
notokenyet, (*set in each line until the first token is scanned*)
elsehere, (*set while an else token is to be printed*)
fwddecl, (*set true by block after 'forward', 'extern'*)
oldspaces, (*set when lastspaces should be used*)
eoline, (*set at end on input line*)
programpresent, (*set after program encountered*)
nobody, (*set if no main body is found*)
firstpage, (*true before writting anything*)
eob : boolean; (*eof-flag*)
errmsg : PACKED ARRAY[errkinds,1..40] OF char; (*error messages*)
ch : ascii; (*last read character*)
(* (*sets*)
(* (******)
delsy : ARRAY [' '..'←'] OF symbol; (*type array for delimiter characters*)
resnum: ARRAY['A'..'['] OF integer; (*index of the first keyword beginning with the indexed letter*)
reslist : ARRAY [1..46] OF alfa; (*list of the reserved words*)
ressy : ARRAY [1..46] OF symbol; (*type array of the reserved words*)
alphanum, (*characters from 0..9 and a..z*)
digits : SET OF char; (*characters from 0..9*)
openblocksym, (*symbols after which a basic block starts*)
relevantsym, (*start symbols for statements and procedures*)
prosym, (*all symbols which begin a procedure*)
decsym, (*all symbols which begin declarations*)
begsym, (*all symbols which begin compound statements*)
endsym : SET OF symbol; (*all symbols which terminate statements or procedures*)
(* (*pointers and files*)
(* (********************)
old←name: pack9; (*used to get the parameter files*)
old←dev: pack6;
old←prot,old←ppn: integer;
programname,oldfileid: alfa;
oldsource: text;
new←name: pack9;
new←dev: pack6;
new←prot,new←ppn: integer;
newfileid: alfa;
newsource: text;
(*initialization:*) (*initprocedures,reinitialize,initialize*)
INITPROCEDURE;
BEGIN (*constants*)
elsehere := false;
elseifing := false;
eob := false;
indentbegin:=0;
begexd:=0;
goodversion := -1;
rescase:=true;
nonrcase:=false;
strcase:=true;
nobody := false;
anyversion := false;
oldfileid:='OLDSOURCE ';
feed:=4;
comcase:=false;
new←name:=' ';
programname:='PFORM ';
newfileid:='NEWSOURCE ';
END (*constants*);
INITPROCEDURE;
BEGIN (*reserved words*)
resnum['A'] := 1; resnum['B'] := 3; resnum['C'] := 4;
resnum['D'] := 6; resnum['E'] := 9; resnum['F'] := 13;
resnum['G'] := 18; resnum['H'] := 19; resnum['I'] := 19;
resnum['J'] := 22; resnum['K'] := 22; resnum['L'] := 22;
resnum['M'] := 24; resnum['N'] := 25; resnum['O'] := 27;
resnum['P'] := 30; resnum['Q'] := 33; resnum['R'] := 33;
resnum['S'] := 35; resnum['T'] := 36; resnum['U'] := 39;
resnum['V'] := 40; resnum['W'] := 41; resnum['X'] := 43;
resnum['Y'] := 43; resnum['Z'] := 43; resnum['['] := 43;
reslist[ 1] :='AND '; ressy [ 1] := othersy;
reslist[ 2] :='ARRAY '; ressy [ 2] := othersy;
reslist[ 3] :='BEGIN '; ressy [ 3] := beginsy;
reslist[ 4] :='CASE '; ressy [ 4] := casesy;
reslist[ 5] :='CONST '; ressy [ 5] := constsy;
reslist[ 6] :='DO '; ressy [ 6] := dosy;
reslist[ 7] :='DIV '; ressy [ 7] := othersy;
reslist[ 8] :='DOWNTO '; ressy [ 8] := othersy;
reslist[ 9] :='END '; ressy [ 9] := endsy;
reslist[10] :='ELSE '; ressy [10] := elsesy;
reslist[11] :='EXIT '; ressy [11] := exitsy;
reslist[12] :='EXTERN '; ressy [12] := externsy;
reslist[13] :='FOR '; ressy [13] := forsy;
reslist[14] :='FILE '; ressy [14] := othersy;
reslist[15] :='FORWARD '; ressy [15] := forwardsy;
reslist[16] :='FUNCTION '; ressy [16] := functionsy;
reslist[17] :='FORTRAN '; ressy [17] := externsy;
reslist[18] :='GOTO '; ressy [18] := gotosy;
reslist[19] :='IF '; ressy [19] := ifsy;
reslist[20] :='IN '; ressy [20] := othersy;
reslist[21] :='INITPROCED'; ressy [21] := initprocsy;
reslist[22] :='LOOP '; ressy [22] := loopsy;
reslist[23] :='LABEL '; ressy [23] := labelsy;
reslist[24] :='MOD '; ressy [24] := othersy;
reslist[25] :='NOT '; ressy [25] := othersy;
reslist[26] :='NIL '; ressy [26] := othersy;
reslist[27] :='OR '; ressy [27] := othersy;
reslist[28] :='OF '; ressy [28] := ofsy;
reslist[29] :='OTHERS '; ressy [29] := otherssy;
reslist[30] :='PACKED '; ressy [30] := othersy;
reslist[31] :='PROCEDURE '; ressy [31] := proceduresy;
reslist[32] :='PROGRAM '; ressy [32] := programsy;
reslist[33] :='RECORD '; ressy [33] := recordsy;
reslist[34] :='REPEAT '; ressy [34] := repeatsy;
reslist[35] :='SET '; ressy [35] := othersy;
reslist[36] :='THEN '; ressy [36] := thensy;
reslist[37] :='TO '; ressy [37] := othersy;
reslist[38] :='TYPE '; ressy [38] := typesy;
reslist[39] :='UNTIL '; ressy [39] := untilsy;
reslist[40] :='VAR '; ressy [40] := varsy;
reslist[41] :='WHILE '; ressy [41] := whilesy;
reslist[42] :='WITH '; ressy [42] := othersy;
END (*reserved words*);
INITPROCEDURE;
BEGIN (*sets*)
digits := ['0'..'9'];
alphanum := ['0'..'9','A'..'Z'] (*letters or digits*);
decsym := [labelsy,constsy,typesy,varsy,programsy];
prosym := [functionsy..initprocsy];
endsym := [functionsy..eobsy]; (*prosym or endsymbols*)
begsym := [beginsy..ifsy];
relevantsym := [labelsy..initprocsy (*decsym or prosym*),beginsy,forwardsy,externsy,eobsy];
openblocksym := [thensy,elsesy,dosy,loopsy,repeatsy,intconst,colon,exitsy]
END (*sets*);
INITPROCEDURE;
BEGIN (*error messages*)
errmsg[begerrinblkstr] := 'ERROR IN BLOCK STRUCTURE: BEGIN EXPECTED';
errmsg[missgend ] := 'MISSING ''END'' STATEMENT NUMBER ';
errmsg[missgthen ] := 'MISSING ''THEN'' FOR ''IF'' NUMBER ';
errmsg[missgof ] := 'MISSING ''OF'' IN ''CASE'' NUMBER ';
errmsg[missgexit ] := 'MISSING ''EXIT'' IN ''LOOP'' NUMBER ';
errmsg[missgrpar ] := 'MISSING RIGHT PARENTHESIS ';
errmsg[missgquote ] := 'MISSING CLOSING QUOTE ON THIS LINE ';
errmsg[missgmain ] := 'WARNING: THIS FILE HAS NO MAIN BODY ';
errmsg[missgpoint ] := 'MISSING CLOSING POINT AT END OF PROGRAM.';
errmsg[linetoolong ] := 'LINE TOO LONG. I''M GONNA GET CONFUSED. ';
errmsg[missguntil ] := 'MISSING ''UNTIL'' FOR ''REPEAT'' NUMBER ';
errmsg[missgrbrack ] := 'MISSING RIGHT BRACKET ';
END (*error messages*);
PROCEDURE reinitialize;
VAR
lch: char;
BEGIN (*reinitialize*)
bufflen := 0; buffmark := 0; errcount := 0;
bufferptr := 2; variant←level := 0; level := 0;
line500 := 0; linecnt :=0; pagecnt := 1;
eoline := true; firstpage := true; notokenyet := true;
programpresent := false; oldspaces := false; incondcomp := false;
sy := blanks; prog←name := blanks;
END (*reinitialize*);
PROCEDURE initialize;
VAR
i: integer;
BEGIN (*initialize*)
FOR ch := ' ' TO '←' DO
delsy [ch] := othersy;
delsy ['('] := lparent;
delsy [')'] := rparent;
delsy ['['] := lbracket;
delsy [']'] := rbracket;
delsy [';'] := semicolon;
delsy ['.'] := point;
delsy [':'] := colon;
delsy ['='] := eqlsy;
FOR i := -1 TO 201 DO
buffer [i] := ' ';
FOR i := 1 TO 17 DO
tabs [i] := chr (ht);
FOR ch := nul TO '@' DO
lower[ch] := ch;
FOR ch := 'A' TO 'Z' DO
lower[ch] := chr (ord(ch) + 40B);
FOR ch := '[' TO del DO
lower[ch] := ch;
reinitialize;
END (*initialize*);
(*ccl scanner:*) (*getdirectives[setswitch]*)
PROCEDURE getdirectives;
(* checks the presence of switches with the file names. *)
VAR
brkchar: char;
try: integer;
fromtmp: boolean;
PROCEDURE setswitch(opt:alfa;VAR switch:boolean);
VAR
i: integer;
BEGIN (*setswitch*)
getoption(opt,i);
IF i=ord('L') THEN
switch:=false
ELSE
IF i=ord('U') THEN
switch:=true;
END (*setswitch*);
BEGIN (*getdirectives*)
getparameter(oldsource,oldfileid,programname,true);
getstatus(oldsource,old←name,old←prot,old←ppn,old←dev);
askfilename(new←name,new←prot,new←ppn,new←dev,newfileid,programname,false,fromtmp,brkchar);
IF (new←name = ' ') AND (new←dev = 'DSK ') THEN
BEGIN
getstatus(oldsource, new←name,old←prot,old←ppn,old←dev);
new←name[7]:='N';
new←name[8]:='E';
new←name[9]:='W';
END;
startfile(newsource,new←name,new←prot,new←ppn,new←dev,false,newfileid,' ');
IF option ('VERSION ') THEN
BEGIN
getoption ('VERSION ',goodversion);
IF goodversion > 9 THEN
BEGIN
goodversion := -1;
anyversion := true;
END;
END;
IF option('INDENT ') THEN
BEGIN
getoption('INDENT ',feed);
IF feed < 0 THEN
feed:=4;
END;
IF option('BEGIN ') THEN
BEGIN
getoption('BEGIN ',indentbegin);
IF indentbegin < 0 THEN
BEGIN
begexd:=-indentbegin;
indentbegin:=0;
END;
END;
forcing:=forcing OR option('FORCE ');
elseifing := option ('ELSEIF ');
IF option('CASE ') THEN
BEGIN
setswitch('CASE ',rescase);
nonrcase:=rescase;
comcase:=rescase;
strcase:=rescase;
END;
setswitch('RES ',rescase);
setswitch('NONRES ',nonrcase);
setswitch('COMM ',comcase);
setswitch('STR ',strcase);
END (*getdirectives*);
(*page control:*) (*newpage*)
PROCEDURE newpage;
BEGIN (*newpage*)
pagecnt := pagecnt + 1;
IF eoln (oldsource) THEN
readln(oldsource);
linecnt := 0;
line500 := 0;
IF prog←name <> blanks THEN
write(tty,pagecnt:3,'..');
break(tty);
IF firstpage THEN
firstpage := false
ELSE
page(newsource);
END (*newpage*);
(*output procs:*) (*block[error,writeline]*)
PROCEDURE block;
VAR
i: integer;
itisaproc : boolean; (*true when the word procedure is found*)
lastprocname: alfa; (*implicit stack of procedure names for the header*)
PROCEDURE error (errnr : errkinds);
BEGIN (*error*)
errcount := errcount+1;
write (newsource, '(*??* ');
CASE errnr OF
begerrinblkstr: write(newsource, sy, errmsg[begerrinblkstr]);
missgend, missgthen, missguntil,
missgexit : write(newsource, errmsg[errnr]);
OTHERS : write(newsource, errmsg[errnr]);
END;
writeln(newsource,' *??*)');
writeln(tty);
write (tty, 'ERROR AT ', linecnt*increment: linnumsize, '/', pagecnt:2,': ');
CASE errnr OF
begerrinblkstr: write(tty, sy, errmsg[begerrinblkstr]);
missgend, missgthen, missguntil,
missgexit :
write(tty, errmsg[errnr]);
OTHERS : write(tty, errmsg[errnr]);
END;
writeln(tty);
break (tty);
END (*error*) ;
PROCEDURE writeline (position (*letztes zu druckendes zeichen im puffer*): integer);
VAR
ladjust,
i, j, maxchar: integer; (*markiert erstes zu druckendes zeichen*)
BEGIN (*writeline*)
position := position - 2;
IF position > 0 THEN
BEGIN
i := buffmark + 1; (* 1. discard blanks at both ends *)
WHILE (buffer [i] = ' ') AND (i <= position) DO
i := i + 1;
buffmark := position;
WHILE (buffer [position] = ' ') AND (i < position) DO
position := position - 1;
IF i <= position THEN (* 2. if anything left, write it. *)
BEGIN
IF NOT oldspaces THEN
lastspaces := spaces;
write (newsource, tabs:lastspaces DIV 8, ' ':lastspaces MOD 8);
FOR j := i TO position DO
BEGIN
newsource↑ := buffer[j];
put(newsource);
END;
writeln(newsource);
WHILE (buffmark < bufflen) AND (buffer[buffmark] = ' ') DO (* 3. reset pointers and flags *)
buffmark := buffmark + 1;
IF buffmark < bufflen THEN
IF buffer[buffmark - 1] = ' ' THEN
buffmark := buffmark - 1
ELSE
ELSE
IF (linenb = ' ') THEN
BEGIN
newpage;
END
ELSE
IF (linecnt >= maxinc) THEN
newpage;
END (* if i <= position *);
END (* if position > 0 *);
lastspaces := spaces;
oldspaces := false;
thendo := false;
elsehere := false;
END (*writeline*) ;
(*scanner:*) (*insymbol[readbuffer[readline],resword*)
PROCEDURE insymbol ;
LABEL
1,111;
VAR
i: integer;
incondcomp: boolean;
PROCEDURE readbuffer;
(*reads a character from the input buffer*)
PROCEDURE readline;
(*handles leading blanks and blank lines, reads next nonblank line
(without leading blanks) into buffer*)
VAR
ch : char;
i: integer;
BEGIN (*readline*)
(*entered at the beginning of a line*)
LOOP
WHILE eoln (oldsource) AND NOT eof (oldsource) DO
BEGIN
(*is this a page mark?*)
getlinenr (oldsource,linenb);
readln(oldsource);
IF linenb = ' ' THEN
BEGIN
newpage;
END
ELSE (*handle blank line*)
BEGIN
line500 := line500 + 1;
linecnt := linecnt + 1;
IF line500 = 500 THEN
BEGIN
line500 := 0;
write(tty,'(',linecnt:4,')');
break(tty);
END;
writeln(newsource);
IF linecnt >= maxinc THEN
newpage;
END (*handle blank line*);
END (*while eoln(oldsource)...*);
EXIT IF (oldsource↑ <> ' ') OR (eof (oldsource));
get(oldsource);
END (*loop*);
bufflen := 0;
(*read in the line*)
WHILE NOT eoln (oldsource) DO
BEGIN
bufflen := bufflen + 1;
buffer [bufflen] := oldsource↑;
get(oldsource);
END;
IF bufflen > linsize THEN
BEGIN
error(linetoolong);
bufflen := linsize;
END
ELSE
BEGIN
buffer[bufflen+1] := ' '; (*so we can always be one char ahead*)
buffer[bufflen+2] := ' ';
END;
IF NOT eof (oldsource) THEN
BEGIN
getlinenr (oldsource,linenb);
linecnt := linecnt + 1;
line500 := line500 + 1;
IF line500 = 500 THEN
BEGIN
line500 := 0;
write(tty,'(',linecnt:4,')');
break(tty);
END;
readln(oldsource);
END;
bufferptr := 1;
buffmark := 0;
notokenyet := true;
END (*readline*) ;
BEGIN (*readbuffer*)
(*if reading past the extra blank on the end, get a new line*)
IF eoline THEN
BEGIN
writeline (bufferptr);
ch := ' ';
IF eof (oldsource) THEN
eob := true
ELSE
readline;
END
ELSE
BEGIN
ch := buffer [bufferptr];
bufferptr := bufferptr + 1;
END;
eoline := bufferptr >= bufflen + 2;
END (*readbuffer*) ;
FUNCTION resword: boolean ;
(*determines if the current identifier is a reserved word*)
VAR
i,j: integer;
local: boolean;
BEGIN (*resword*)
local:= false;
i := resnum[sy[1]];
WHILE (i < resnum[succ(sy[1])]) AND NOT local DO
IF reslist[ i ] = sy THEN
BEGIN
local := true;
syty := ressy [i];
IF NOT rescase THEN
FOR j := bufferptr - syleng - 1 TO bufferptr - 2 DO
buffer[j] := lower[buffer[j]];
END
ELSE
i := i + 1;
resword := local;
END (*resword*) ;
(*parenthese,docomment*)
PROCEDURE parenthese (which: symbol);
(*handles the formatting of parentheses, except those in variant parts of records*)
VAR
oldspacesmark : integer; (*alter zeichenvorschub bei formatierung von klammern*)
BEGIN (*parenthese*)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := lastspaces + bufferptr - buffmark - 2;
REPEAT
insymbol;
UNTIL syty IN [which,externsy..whilesy,labelsy..typesy,initprocsy..exitsy,dosy..forwardsy];
spaces := oldspacesmark;
oldspaces := true;
IF syty = which THEN
insymbol
ELSE
IF which = rparent THEN
error(missgrpar)
ELSE
error(missgrbrack);
END (*parenthese*) ;
PROCEDURE docomment (dellength: integer; firstch: char);
VAR
oldspacesmark: integer;
BEGIN (* docomment *)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
lastspaces := spaces;
oldspaces := true;
END;
spaces := spaces + bufferptr - 2;
IF dellength = 2 THEN
WHILE NOT ((ch = ')') AND (buffer[bufferptr-2] = '*')) DO
BEGIN
IF NOT comcase THEN
buffer[bufferptr] := lower[buffer[bufferptr]];
readbuffer;
END
ELSE
WHILE ch <> firstch DO
BEGIN
IF NOT comcase THEN
buffer[bufferptr] := lower[buffer[bufferptr]];
readbuffer;
END;
REPEAT
readbuffer;
UNTIL (ch <> ' ') OR eoline;
IF eoline AND notokenyet THEN
readbuffer;
spaces := oldspacesmark;
END (*docomment*);
(*] insymbol*)
BEGIN (*insymbol*)
111:
syleng := 0;
WHILE (ch IN ['←','(',' ','$','?','@','%',backslash,'!']) AND NOT eob DO
CASE ch OF
'(':
BEGIN
readbuffer;
IF (ch = '*') THEN
docomment (2,'*')
ELSE
BEGIN
syty := lparent;
IF variant←level = 0 THEN
parenthese(rparent);
GOTO 1;
END;
END;
'%':
BEGIN
incondcomp := false;
readbuffer;
IF NOT anyversion THEN
WHILE ch IN digits DO
BEGIN
IF ord(ch) - ord('0') = goodversion THEN
incondcomp := true;
readbuffer;
END;
IF NOT (incondcomp OR anyversion) THEN
docomment (1,'\');
END;
OTHERS:
readbuffer;
END;
CASE ch OF
'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q',
'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',
'Z':
BEGIN
syleng := 0;
sy := ' ';
REPEAT
syleng := syleng + 1;
IF syleng <= 10 THEN
sy [syleng] := ch;
readbuffer;
UNTIL NOT (ch IN (alphanum + ['←']));
IF NOT resword THEN
BEGIN
syty := ident ;
IF NOT nonrcase THEN
FOR i := bufferptr - syleng - 1 TO bufferptr - 2 DO
buffer[i] := lower[buffer[i]];
END
END;
'0', '1', '2', '3', '4', '5', '6', '7', '8',
'9':
BEGIN
REPEAT
syleng := syleng + 1;
readbuffer;
UNTIL NOT (ch IN digits);
syty := intconst;
IF ch = 'B' THEN
readbuffer
ELSE
BEGIN
IF ch = '.' THEN
BEGIN
REPEAT
readbuffer
UNTIL NOT (ch IN digits);
syty := othersy; syleng := 0; (*reals can't be labels*)
END;
IF ch = 'E' THEN
BEGIN
readbuffer;
IF ch IN ['+','-'] THEN
readbuffer;
WHILE ch IN digits DO
readbuffer;
syty := othersy; syleng := 0; (*reals can't be labels*)
END;
END;
END;
'''':
BEGIN
syty := strgconst;
REPEAT
REPEAT
IF NOT strcase THEN
buffer[bufferptr] := lower[buffer[bufferptr]];
readbuffer;
UNTIL (ch = '''') OR eob OR eoline;
IF ch <> '''' THEN
error(missgquote);
readbuffer;
UNTIL ch <> '''';
END;
'"':
BEGIN
REPEAT
readbuffer
UNTIL NOT (ch IN (digits + ['A'..'F']));
syty := intconst;
END;
' ': syty := eobsy; (*end of file*)
':': BEGIN
readbuffer;
IF ch = '=' THEN
BEGIN
syty := othersy;
readbuffer;
END
ELSE
syty := delsy[':'];
END;
'\':
BEGIN
readbuffer;
IF incondcomp THEN
BEGIN
incondcomp := false;
GOTO 111;
END
ELSE
syty := othersy;
END;
'[':
BEGIN
syty := lbracket; readbuffer; parenthese(rbracket);
END;
OTHERS:
BEGIN
syty := delsy [ch];
readbuffer;
END
END (*case ch of*);
1:
notokenyet := false;
END (*insymbol*) ;
(*parsing of declarations:*) (*recdef[casedef,parenthese]*)
PROCEDURE recdef;
VAR
oldspacesmark : integer; (*alter zeichenvorschub bei formatierung von records*)
PROCEDURE casedef;
VAR
oldspacesmark : integer; (*alter zeichenvorschub bei formatierung von variant parts*)
PROCEDURE parenthese;
(*handles the formatting of parentheses inside variant parts*)
VAR
oldspacesmark : integer; (*saved value of 'spaces'*)
BEGIN (*parenthese*)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := spaces + bufferptr - 2;
insymbol;
REPEAT
CASE syty OF
casesy :
casedef;
recordsy :
recdef;
rparent: ;
OTHERS :
insymbol;
END;
(*until we apparently leave the declaration*)
UNTIL syty IN [strgconst..whilesy,rparent,labelsy..exitsy,dosy..beginsy,
loopsy..ifsy,forwardsy];
spaces := oldspacesmark;
oldspaces := true;
IF syty = rparent THEN
BEGIN
insymbol;
END
ELSE
error(missgrpar);
END (*parenthese*) ;
BEGIN (*casedef*)
variant←level := variant←level+1;
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := bufferptr - buffmark + lastspaces - syleng + 3;
insymbol;
REPEAT
IF syty = lparent THEN
parenthese
ELSE
insymbol
UNTIL syty IN [untilsy..exitsy,labelsy..endsy,rparent,dosy..beginsy];
spaces := oldspacesmark;
variant←level := variant←level-1;
END (*casedef*) ;
BEGIN (*recdef*)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := bufferptr - buffmark + spaces - syleng - 2 + feed;
insymbol;
REPEAT
CASE syty OF
casesy : casedef;
recordsy : recdef;
OTHERS : insymbol
END;
UNTIL syty IN [untilsy..exitsy,labelsy..endsy,dosy..beginsy];
oldspaces := true;
lastspaces := spaces - feed;
spaces := oldspacesmark;
IF syty = endsy THEN
BEGIN
insymbol;
END
ELSE
error(missgend);
END (*recdef*) ;
(*parsing of statements:*) (*statement[endedstats,compstat,casestat,loopstat,ifstat,labelstat,repeatstat]*)
PROCEDURE statement;
VAR
oldspacesmark, (*spaces at entry of this procedure*)
curblocknr : integer; (*current blocknumber*)
PROCEDURE endedstatseq(endsym: symbol; letter: char);
BEGIN
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
WHILE NOT (syty IN [endsym,eobsy,proceduresy,functionsy]) DO
BEGIN
error(missgend);
IF NOT (syty IN begsym) THEN
insymbol;
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
END;
IF forcing THEN
writeline(bufferptr-syleng);
oldspaces := true;
IF (endsym = endsy) THEN
BEGIN
IF indentbegin = 0 THEN
lastspaces := max(0,spaces-begexd)
ELSE
lastspaces := max(0,spaces-indentbegin);
IF syty <> endsy THEN
error(missgend)
END
ELSE
BEGIN
lastspaces := max(0,spaces - feed);
IF syty <> endsym THEN
error(missguntil);
END;
END (*endedstatseq*);
PROCEDURE compstat;
BEGIN (*compstat*)
IF indentbegin = 0 THEN
BEGIN
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-begexd)
END;
END
ELSE
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - indentbegin);
END;
insymbol;
IF forcing THEN
writeline(bufferptr-syleng);
endedstatseq(endsy, 'E');
IF syty = endsy THEN
BEGIN
insymbol ;
writeline(bufferptr-syleng);
END;
END (*compstat*) ;
PROCEDURE casestat;
VAR
oldspacesmark : integer; (*saved value of 'spaces'*)
BEGIN (*casestat*)
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
insymbol;
statement;
IF syty = ofsy THEN
writeline (bufferptr)
ELSE
error (missgof);
LOOP
REPEAT
REPEAT
insymbol;
UNTIL syty IN [colon, functionsy .. eobsy];
IF syty = colon THEN
BEGIN
oldspacesmark := spaces;
lastspaces := spaces;
spaces := spaces + feed;
(* spaces := bufferptr - buffmark + spaces - 4; *)
oldspaces := true;
thendo := true;
insymbol;
statement;
IF syty = semicolon THEN
insymbol;
spaces := oldspacesmark;
END;
UNTIL syty IN endsym;
EXIT IF syty IN [endsy,eobsy,proceduresy,functionsy];
error (missgend);
END;
writeline(bufferptr-syleng);
IF syty = endsy THEN
BEGIN
insymbol ;
writeline(bufferptr-syleng);
END
ELSE
error (missgend);
END (*casestat*) ;
PROCEDURE loopstat;
BEGIN (*loopstat*)
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
insymbol;
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
IF syty = exitsy THEN
BEGIN
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := spaces-feed;
insymbol; insymbol;
END
ELSE
error(missgexit);
endedstatseq(endsy, 'E');
IF syty = endsy THEN
BEGIN
insymbol ;
writeline(bufferptr-syleng);
END;
END (*loopstat*) ;
PROCEDURE ifstat;
VAR
oldspacesmark: integer;
BEGIN (*ifstat*)
oldspacesmark := spaces;
IF NOT elsehere THEN
BEGIN
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
(*make 'then' and 'else' line up with 'if' unless on same line*)
spaces := lastspaces + bufferptr - buffmark + feed - 4;
END (*if not elsehere*);
insymbol;
statement; (*will eat the expression and stop on a keyword*)
IF syty = thensy THEN
BEGIN
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
IF forcing THEN
writeline(bufferptr)
ELSE
thendo := true;
(*suppress further indentation from a 'do'*)
insymbol;
statement;
END
ELSE
error (missgthen);
IF syty = elsesy THEN (*parse the else part*)
BEGIN
writeline(bufferptr-syleng);
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
IF forcing AND NOT elseifing THEN
writeline(bufferptr)
ELSE
thendo := true;
elsehere := true;
insymbol;
statement;
END;
oldspaces := true; (*preserve indentation of statement*)
writeline(bufferptr-syleng);
spaces := oldspacesmark;
END (*ifstat*) ;
PROCEDURE labelstat;
BEGIN (*labelstat*)
lastspaces := level * feed;
oldspaces := true;
insymbol;
writeline(bufferptr-syleng);
END (*labelstat*) ;
PROCEDURE repeatstat;
BEGIN
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
insymbol;
endedstatseq(untilsy, 'U');
IF syty = untilsy THEN
BEGIN
insymbol;
statement;
writeline(bufferptr-syleng);
END;
END (*repeatstat*) ;
BEGIN (*statement*)
oldspacesmark := spaces; (*save the incoming value of spaces to be able to restore it*)
IF syty = intconst THEN
BEGIN
insymbol;
IF syty = colon THEN
labelstat;
END;
IF syty IN begsym THEN
BEGIN
IF NOT thendo THEN
BEGIN
writeline(bufferptr-syleng);
IF (syty <> beginsy) THEN
spaces := spaces + feed
ELSE
spaces:=spaces + indentbegin;
END;
CASE syty OF
beginsy : compstat;
loopsy : loopstat;
casesy : casestat;
ifsy : ifstat;
repeatsy: repeatstat
END;
END
ELSE
BEGIN
IF forcing THEN
IF syty IN [forsy,whilesy] THEN
writeline(bufferptr-syleng);
WHILE NOT (syty IN [semicolon,functionsy..recordsy]) DO
insymbol;
IF syty = dosy THEN
BEGIN
IF NOT thendo THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
spaces := spaces + feed;
IF NOT forcing THEN
thendo := true;
END;
insymbol;
statement;
writeline(bufferptr-syleng);
END;
END;
spaces := oldspacesmark;
END (*statement*) ;
(*]block*)
BEGIN (*block*)
REPEAT
insymbol;
UNTIL syty IN relevantsym;
level := level + 1;
spaces := level * feed;
REPEAT
fwddecl := false;
WHILE syty IN decsym DO (*declarations: labels, types, vars*)
BEGIN
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := max(0,spaces-feed);
IF syty = programsy THEN
BEGIN
programpresent := true;
insymbol;
prog←name := sy;
writeln(tty);
write(tty,version:verlength,': ',old←name:6,' [ ',prog←name,' ] PAGE');
FOR i := 1 TO pagecnt DO
write (tty, i:3,'..');
break(tty);
END
ELSE (*syty <> programsy*)
BEGIN
IF forcing THEN
writeline(bufferptr);
END (*syty <> programsy*);
REPEAT
insymbol;
IF syty = recordsy THEN
recdef;
UNTIL syty IN relevantsym;
END;
WHILE syty IN prosym DO (*procedure and function declarations*)
BEGIN
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := max(0,spaces-feed);
IF syty <> initprocsy THEN
insymbol;
block;
IF syty = semicolon THEN
insymbol;
END (*while syty in prosym*)
(*forward and external declarations may come before 'var', etc.*)
UNTIL NOT fwddecl;
IF forcing THEN
writeline(bufferptr-syleng);
level := level - 1;
spaces := level * feed;
IF NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy]) THEN
BEGIN
IF (level = 0) AND (syty = point) THEN
nobody := true
ELSE
error (begerrinblkstr);
WHILE NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy,point]) DO
insymbol
END;
IF syty = beginsy THEN
statement
ELSE
IF NOT nobody THEN
BEGIN
fwddecl := true;
insymbol;
END;
IF level = 0 THEN
IF programpresent THEN
BEGIN
IF nobody THEN
BEGIN
error (missgmain);
errcount := errcount - 1;
END;
IF syty <> point THEN
error(missgpoint);
writeline(bufflen+2);
writeln(tty);
writeln (tty,errcount:4,' ERROR(S) DETECTED'); break(tty);
END (*if level = 0*);
END (*block*) ;
(*main program*)
BEGIN
settime;
getdirectives;
initialize;
(*find max possible line number with this increment*)
maxinc := (99999 DIV increment);
IF maxinc > 4000 THEN
maxinc := 4000;
LOOP
block;
EXIT IF NOT programpresent OR (syty = eobsy);
reinitialize;
END;
timereport(ttyoutput, ' ');
END (*pcross*).